home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 13.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  30KB  |  1,044 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #ifndef SEM
  11. #define SEM    1
  12. #endif
  13.  
  14. #include "hdr.h"
  15. #include "vars.h"
  16. #include "attr.h"
  17. #include "setp.h"
  18. #include "dclmapp.h"
  19. #include "arithp.h"
  20. #include "errmsgp.h"
  21. #include "miscp.h"
  22. #include "smiscp.h"
  23. #include "chapp.h"
  24.  
  25.  
  26. /* 13. Representation Clauses*/
  27.  
  28. #define max_val(x,y)    ((x) > (y) ? (x) : (y)) 
  29.  
  30. #define rc_unset                 0    
  31. #define rc_set                    1
  32. #define rc_default                (-1)
  33.  
  34. #define storage_unit             32
  35. #define padding                  0
  36.  
  37. #define size_position            2
  38. #define storage_size_position    4
  39. #define small_position           4
  40. #define pack_position            4
  41. #define literal_map_position     4
  42. #define alignment_position       6
  43.  
  44. /*
  45.  * Currently the representation information is structured as follows:
  46.  *
  47.  * integer & floating point types
  48.  * [size]
  49.  *
  50.  * task & access types
  51.  * [size, storage_size]
  52.  *
  53.  * fixed point types
  54.  * [size] -- small is kept in the symbol table as 5th entry of signature
  55.  *
  56.  * array types
  57.  * [size, pack]
  58.  *
  59.  * record types
  60.  * [size, pack, [modulus, [[field, pos, first_bit, last_bit],...]]]
  61.  *
  62.  * enumeration types
  63.  * [size, literal_map]
  64.  *
  65.  */
  66.  
  67. static char *default_representation(Symbol, int);
  68. static void apply_length_clause(int, Symbol, Node);
  69. static void apply_enum_clause(Symbol, Tuple);
  70. static void apply_record_clause(Symbol, int, Tuple);
  71. static Tuple not_chosen_get(Symbol);
  72. static void not_chosen_delete(Symbol);
  73. static int default_size_value(Symbol);
  74. static int component_size(Symbol);
  75. static Tuple default_record_value(Symbol);
  76. extern int ADA_MAX_INTEGER;
  77.  
  78. void initialize_representation_info(Symbol type_name, int tag)
  79. /*;initialize_representation_info */
  80.  
  81. {
  82. /*
  83.  * Initialize the representation information of the given type by setting
  84.  * all its fields to the status unset. 
  85.  */
  86. Tuple    rctup;
  87. if (tag == TAG_RECORD) {
  88.    rctup = tup_new(7);
  89.    rctup[1] = (char *) tag;
  90.    rctup[2] = (char *) rc_unset;
  91.    rctup[4] = (char *) rc_unset;
  92.    rctup[6] = (char *) rc_unset;
  93. }
  94. else if (tag == TAG_TASK    || tag == TAG_ACCESS    ||
  95.          tag == TAG_ARRAY    || tag == TAG_ENUM) {
  96.    rctup = tup_new(5);
  97.    rctup[1] = (char *) tag;
  98.    rctup[2] = (char *) rc_unset;
  99.    rctup[4] = (char *) rc_unset;
  100. }
  101. else {            /*  TAG_INT  || TAG_FIXED */
  102.    rctup = tup_new(3);
  103.    rctup[1] = (char *) tag;
  104.    rctup[2] = (char *) rc_unset;
  105. }
  106. RCINFO(type_name) = rctup;
  107. FORCED(type_name) = FALSE;
  108. not_chosen_put(type_name, (Symbol)0);
  109. }
  110.  
  111. void choose_representation(Symbol type_name)
  112. /*;choose_representation(type_name)*/
  113. {
  114. Symbol    b_type;
  115. Tuple    current_rep;
  116. Tuple    tup;
  117. int        status,i,n;
  118.  
  119. b_type = base_type(type_name);
  120. current_rep = RCINFO(b_type);
  121.  
  122. if (current_rep == (Tuple)0) {
  123.    REPR(type_name) = (Tuple)0;
  124.    return;
  125. }
  126. n = tup_size(current_rep);
  127. for (i=2; i<=n; i+=2) { 
  128.    status = (int) current_rep[i];
  129.    if (status == rc_unset) {
  130.       current_rep[i] = (char *) rc_default;
  131.       current_rep[i+1] = (char *) default_representation(type_name,i);
  132.    }
  133. }
  134. tup = tup_new((n/2)+1);
  135. tup[1] = current_rep[1];
  136. for (i=1; i<=(n/2); i++) { 
  137.   tup[i+1] = current_rep[2*i+1];
  138. }
  139. REPR(type_name) = tup;
  140. }
  141.  
  142. void inherit_representation_info(Symbol derived_type, Symbol parent_type)
  143. /*; inherit_representation_info */
  144. {
  145. Symbol    b_type;
  146. Symbol    v_type;
  147. Tuple    current_rep;
  148. int        i,n;
  149.  
  150. /*
  151.  * A derived type inherits all the representation information of its parent.
  152.  * However, this information is only considered to have a status of a 'default'
  153.  * representation which may be overidden by an explicit representation clause
  154.  * given to the derived type. It is therefore necessary to change the status
  155.  * field of the derived type when the parent had the status of 'set'.
  156.  */
  157.  
  158. /*
  159.  * If the parent type is private we must retrieve its base type from the
  160.  * private_decls entry
  161.  */
  162.    if (TYPE_OF(parent_type) == symbol_private ||   
  163.        TYPE_OF(parent_type) == symbol_limited_private) {
  164.        v_type = private_decls_get((Private_declarations)
  165.                       private_decls(SCOPE_OF(parent_type)), parent_type);
  166.         /*
  167.          * Check to seem if vis_decl is defined before accessing it. It might be
  168.          * undefined in the case of compilation errors.
  169.          */
  170.          if (v_type != (Symbol)0) {
  171.              b_type = TYPE_OF(v_type);     /* TYPE_OF field in the symbol table */
  172.          }
  173.          else {
  174.            return;
  175.          }
  176.     }
  177.     else  {
  178.            b_type = base_type(parent_type);
  179.     }
  180.     current_rep = RCINFO(b_type);
  181.     if (current_rep == (Tuple)0) {
  182.         return;
  183.     }
  184.     current_rep = tup_copy((Tuple)RCINFO(b_type));
  185.     n = tup_size(current_rep);
  186.     for (i=2;i<=n;i+=2) {
  187.           if ((int)current_rep[i] == rc_set) {
  188.               current_rep[i] = (char *) rc_default;
  189.         }
  190.         else if ((int) current_rep[i] == rc_unset) {
  191.               current_rep[i] = (char *) rc_default;
  192.             current_rep[i+1] = (char *) default_representation(derived_type,i);
  193.            }
  194.      }
  195.     RCINFO(derived_type) = current_rep;
  196.     FORCED(derived_type) = FALSE;
  197.     not_chosen_put(derived_type, (Symbol)0);
  198. }
  199. already_forced(Symbol type_name)                 /*; already_forced */
  200. {
  201. int    result;
  202. result = FORCED(type_name);
  203. return result;
  204. }
  205.  
  206. void force_representation(Symbol type_name)         /*; force_representation */
  207. {
  208. Symbol     b_type,r_type,v_type,sym;
  209. Fortup    ft1;    
  210. Tuple    current_rep,tup,field_names;
  211. int        i,n;
  212.  
  213. b_type = base_type(type_name);
  214.  
  215. /* Check if type has already been forced. */
  216. if (already_forced(b_type)) {
  217.    return;
  218. }
  219. else {
  220.    if (is_generic_type(b_type)) {
  221.   /*
  222.    * There is no need to force a generic formal type since any use of this
  223.    * type will refer to the generic actual parameter after the instantiation
  224.    * and therefore the representation information is just that of the actual.
  225.    * Subtypes of generic formal types will be handled differently with the
  226.    * 'delayed_repr' instruction generated in Subtype_Declaration.
  227.    */
  228.       not_chosen_delete(b_type);
  229.       return;
  230.    }
  231. #ifdef TBSL
  232.    else if (has_generic_component(b_type)) {
  233.    /* If a type has generic components its forcing must be delayed until
  234.     * the point of instantiation when the representation of the actuals are
  235.     * known, since the representation of the record or array is dependent on
  236.     * the representation of the generic components. The replace routine will
  237.     * choose the representation for all
  238.     * delayed reprs.
  239.     */
  240.       delayed_reprs with:= b_type;
  241.       FORCED(b_type) = TRUE;
  242.       return;
  243.    }
  244. #endif
  245.    FORCED(b_type) = TRUE;
  246.    current_rep = RCINFO(b_type);
  247.    if (current_rep == (Tuple)0) {
  248.       /* some sort of error condition */
  249.       not_chosen_delete(b_type);
  250.       return;
  251.    }
  252.    n = tup_size(current_rep);
  253.    for (i=2;i<=n;i+=2) {
  254.      if ((int)current_rep[i] == rc_default) {
  255.         current_rep[i] = (char *) rc_set;
  256.      }
  257.    }
  258.    RCINFO(b_type) = current_rep;
  259.   /*
  260.    * Force all component fields of the record type before the representation is
  261.    * decided for the record type since the component types may affect the size
  262.    * of the record.
  263.    */
  264.  
  265.    if (is_record(b_type)) {
  266.       r_type = root_type(type_name);
  267.       if (TYPE_OF(r_type) == symbol_private ||
  268.           TYPE_OF(r_type) == symbol_limited_private) {
  269.           v_type = private_decls_get((Private_declarations)
  270.                          private_decls(SCOPE_OF(r_type)), r_type);
  271.           if (v_type == (Symbol)0) {         /* error condition */
  272.               not_chosen_delete(b_type);
  273.               return;
  274.           }
  275.           field_names = build_comp_names((Node) invariant_part(v_type));
  276.       }
  277.       else {
  278.           field_names = build_comp_names((Node) invariant_part(b_type));
  279.       }
  280.       FORTUP(sym=(Symbol),field_names,ft1);
  281.          force_representation(TYPE_OF(sym));
  282.       ENDFORTUP(ft1);
  283.    }
  284.    choose_representation(b_type);
  285.    tup = not_chosen_get(b_type);
  286.    FORTUP(sym=(Symbol),tup, ft1);
  287.      choose_representation(sym);
  288.    ENDFORTUP(ft1);
  289.    not_chosen_delete(b_type);
  290. }
  291. }
  292. void force_all_types()                                 /*; force_all_types */
  293. {
  294. Symbol    b_type;
  295.  
  296. /*
  297.  * Called at the end of a declarative part, to force all types not already
  298.  * affected by a forcing occurence.
  299.  */
  300.  
  301. while (tup_size(NOT_CHOSEN) > 0) {
  302.    b_type = (Symbol) NOT_CHOSEN[1];
  303.    force_representation(b_type);
  304. }
  305. }
  306. static char *default_representation(Symbol type_name,int position)
  307. /*;default_representation */
  308. {
  309.    switch (position) {
  310.       case(size_position):
  311.        return (char *) default_size_value(type_name);
  312.  
  313.       case(storage_size_position):
  314.           if (is_task_type(type_name) || is_access(type_name)) {
  315.              return (char *) OPT_NODE;
  316. #ifdef TBSL
  317.               return (char *) new_ivalue_node(int_const(ADA_MAX_INTEGER), 
  318.                              symbol_integer);
  319. #endif
  320.           }
  321.           else if (is_fixed_type(type_name)) {
  322.               return (char *) default_size_value(type_name);
  323.           }
  324.           else if (is_array(type_name)) {
  325.           /* (pack_position) */
  326.            return (char *) FALSE;
  327.           }
  328.           else if (NATURE(type_name) == na_enum)  {
  329.            /*(literal_map_position) */
  330.            return (char *) literal_map(type_name);
  331.           }
  332.           break;
  333.  
  334.        case(alignment_position):
  335.          return (char *) default_record_value(type_name);
  336.    }
  337. }
  338.  
  339. /*
  340.  * Changes:
  341.  * 7/10/86     ACD     
  342.  *  Allowed a 'small' field be processed for fixed-point numbers.  This
  343.  *  entailed enabling the function 'length_clause' to process smalls.
  344.  *  Only 'smalls' which are a power of 10 or 2 are allowed (this is
  345.  *  checked in the routine 'make_fixed_template' in type.c in code generator.
  346.  *  Note that all other length specifications are still disabled
  347.  *
  348.  *  In addition, the processing of 'SMALL' the call to 'check_type' was     
  349.  *  modified to "check_type_r(expn)" instead of "check_type(attr_prefix, expn)"
  350.  *  This is how it was done in the SETL system.
  351.  */
  352. void length_clause(Node node)                    /*;length_clause*/
  353. {
  354.     Node    attr_node,expn,a_node,arg1;
  355.     int        attr_kind,nk;
  356.     Symbol    b_type,attr_prefix;
  357.     Tuple    tsig;
  358.  
  359. /*
  360.  *  This procedure processes a length clause.  
  361.  *  It first performs semantic actions on the length clause and the expression
  362.  *  associated with the clause and initializes variables.  If the clause is
  363.  *  a SMALL clause, then it checks that the prefix is a type with fixed
  364.  *  root type.  If so, then it checks that the expression is an ivalue.
  365.  *  If it passes both of these checks then the value of the small is added
  366.  *  to the type constraint.
  367.  */
  368.      attr_node = N_AST1(node);
  369.      expn      = N_AST2(node);
  370.      adasem(attr_node);
  371.      adasem(expn);
  372.      a_node = N_AST1(attr_node);
  373.      arg1 = N_AST2(attr_node);
  374.      attr_kind = (int) attribute_kind(attr_node);
  375.      find_old(arg1);
  376.      attr_prefix = N_UNQ(arg1);
  377.  
  378. if (attr_kind == ATTR_SIZE) {
  379.    if (is_type(attr_prefix)) {
  380.       check_type (symbol_integer, expn);
  381.      if (is_static_expr(expn)) {
  382.        apply_length_clause(attr_kind, attr_prefix, expn);
  383.      }
  384.      else {
  385.      errmsg("Expression in size spec is not static","13.2",expn);
  386.      }
  387.    }
  388.    else {
  389.       errmsg("Prefix of attribute is not type or first named subtype", "13.2", expn);
  390.    }
  391. }
  392.      if (attr_kind == ATTR_SMALL) {
  393.         if (!is_type(attr_prefix) || root_type(attr_prefix) != symbol_dfixed) { 
  394.         errmsg("expect fixed type in representation clause for SMALL",
  395.                    "13.2(11)", arg1) ;
  396.             return ;
  397.  
  398.         }  
  399.         else {
  400.          check_type_r(expn) ;
  401.              nk = N_KIND(expn);
  402.          if (nk!=as_ivalue && nk!=as_int_literal && nk!=as_real_literal) { 
  403. /*  The expression is not static.  Do not have to check whether it is a real */
  404. /*  or not, if it is not then an error was already emitted by check_type_r   */
  405.              errmsg("expression for SMALL must be static","13.2(11)",expn);
  406.              return ;
  407.          }   
  408.          else {
  409.                  b_type = TYPE_OF(attr_prefix);
  410.              tsig = SIGNATURE(b_type);
  411.              tsig[5] = (char *) expn;
  412.          }
  413.      }
  414. }
  415. else if (attr_kind == ATTR_STORAGE_SIZE) {
  416.    if (is_task_type(attr_prefix) || 
  417.        is_anonymous_task(attr_prefix) || 
  418.        is_access(attr_prefix)) {
  419.       check_type (symbol_integer, expn);
  420.       apply_length_clause(attr_kind, attr_prefix, expn);
  421.    }
  422.    else {
  423.       errmsg("Prefix of attribute is not task type or access type", "13.2", expn);
  424.    }
  425. }
  426.  
  427. else if (attr_kind == ATTR_SMALL) { 
  428.     if (!is_type(attr_prefix) || root_type(attr_prefix) != symbol_dfixed) { 
  429.     errmsg("expect fixed type in representation clause for SMALL", "13.2(11)", arg1) ;
  430.     return ;
  431.     }
  432.     else {
  433.     check_type(attr_prefix, expn) ;
  434.     if (N_KIND(expn) != as_ivalue) { 
  435.      errmsg("expression for SMALL must be static","13.2(11)",expn);
  436.      return ;
  437.     }
  438.     else {
  439.         /* specified value of small is added to the type constraint. */
  440.         b_type = TYPE_OF(attr_prefix);
  441.         tsig = SIGNATURE(b_type);
  442.         tsig[5] = (char *) expn;
  443.     }
  444.     }
  445. }
  446. }
  447. static void apply_length_clause(int attr_kind, Symbol type_name, Node value)
  448. /*;apply_length_clause */
  449. {
  450.     Symbol b_type;
  451.     Tuple    current_rep;
  452.  
  453.     b_type = base_type(type_name);
  454.     current_rep = RCINFO(b_type);
  455.    if (attr_kind == ATTR_SIZE) {
  456.       current_rep[size_position] = (char *) rc_set;
  457.       current_rep[size_position+1] = (char *) INTV((Const) N_VAL(value));
  458.    }
  459.    else if (attr_kind == ATTR_STORAGE_SIZE) { 
  460.       current_rep[storage_size_position] = (char *) rc_set;
  461.       current_rep[storage_size_position+1] = (char *) value;
  462.    }
  463.    else { /* SMALL */
  464.    }
  465. }
  466. void enum_rep_clause(Node node)                            /*;enum_rep_clause*/
  467. {
  468.  
  469. Node    name_node,aggr_node,def_node;
  470. Node    indx_node,index_list_node,type_indic_node;
  471. Node    aggr_list_node;
  472. Symbol    type_name,enum_aggr_type;
  473. Tuple    old_lit_map,rep_lit_map,seq,tup;
  474. int        i,n; 
  475.  
  476. /* This procedure checks the validity of the representation clause for
  477.  * enumeration types. 
  478.  */
  479.  name_node = N_AST1(node); 
  480.  aggr_node = N_AST2(node);
  481.  find_old(name_node);
  482.  type_name = N_UNQ(name_node);
  483.  if (NATURE(root_type(type_name)) != na_enum) {
  484.     errmsg("Identifier is not an enumeration type", "13.3", name_node);
  485.     return;
  486.   }
  487.  
  488. /*
  489.  * The representation is given by a aggregate, whose index type is the
  490.  * given  enumeration  type,  and whose component  type is integer. We
  491.  * build such an array type for type checking, but emit no code for it.
  492.  */
  493.     enum_aggr_type = find_new(newat_str());
  494.     index_list_node = node_new(as_list);
  495.     indx_node = node_new(as_simple_name);
  496.     N_UNQ(indx_node) = type_name;
  497.     N_LIST(index_list_node) = tup_new1((char *)indx_node);
  498.     type_indic_node = node_new(as_simple_name);
  499.     N_UNQ(type_indic_node) = symbol_integer;
  500.     def_node = node_new(as_array_type);
  501.     N_AST1(def_node) = index_list_node;
  502.     N_AST2(def_node) = type_indic_node;
  503.     
  504.     new_constrained_array(enum_aggr_type, def_node);
  505.     tup = (Tuple) newtypes[tup_size(newtypes)];
  506.     tup_frome(tup);
  507.     
  508.     adasem (aggr_node);
  509.     check_type (enum_aggr_type, aggr_node);
  510.     /*if (is_static_expr(aggr_node)) {*/
  511.     if (1) {
  512.       aggr_list_node = N_AST1(aggr_node);
  513.       seq = N_LIST(N_AST1(aggr_list_node));
  514.       n = tup_size(seq);
  515.       for (i=1;i<n;i++) {
  516.          if (const_ge((Const)N_VAL((Node)seq[i]),
  517.                       (Const)N_VAL((Node)seq[i+1]))) {
  518.         errmsg_l("Integer code is not distinct or violates ",
  519.                "predefined ordering relation of type","13.3",aggr_node);
  520.         return;
  521.          }
  522.       }
  523.         old_lit_map = (Tuple) OVERLOADS(type_name);
  524.         rep_lit_map = tup_new(n * 2);
  525.         for (i=1;i<=n;i++) {
  526.              rep_lit_map[2*i-1] = strjoin(old_lit_map[2*i-1], "");;
  527.              rep_lit_map[2*i] = (char *)  INTV((Const)N_VAL((Node)seq[i]));
  528.       }
  529.           apply_enum_clause(type_name, rep_lit_map);
  530.       }
  531.         else {
  532.          errmsg_l("Component of aggregate in enumeration representation clause",
  533.                   "is not static","13.3",aggr_node);
  534.          return ;
  535.     }
  536. }
  537. static void apply_enum_clause(Symbol type_name, Tuple rep_lit_map) 
  538. /*;apply_enum_clause*/
  539. {
  540. Symbol    b_type;
  541. Tuple    current_rep;
  542.  
  543. b_type = base_type(type_name);
  544. current_rep = (Tuple) RCINFO(b_type);
  545. if (current_rep == (Tuple)0) {
  546.   initialize_representation_info(b_type, TAG_ENUM);
  547.   current_rep = (Tuple) RCINFO(b_type);
  548. }
  549. current_rep[literal_map_position] = (char *) rc_set;
  550. current_rep[literal_map_position+1] = (char *) rep_lit_map;
  551. }
  552.  
  553. void rec_rep_clause(Node node)                 /*;rec_rep_clause */
  554.  
  555. {
  556. int        repr_err;
  557. int        modulus_value;
  558. Node    name_node;
  559. Symbol    type_name,comp;
  560. Node    align_clause,comp_clause_list;
  561. char    *field;
  562. Tuple    field_names,location_lists, duplic_list, loc_list;
  563. Node    comp_clause, rel_addr, bit_range,first_bit, last_bit;
  564. int        rel_addr_val;
  565. Fortup    ft1;
  566. Fordeclared    fd;
  567.  
  568. name_node = N_AST1(node);
  569. align_clause = N_AST2(node);
  570. comp_clause_list = N_AST3(node);
  571.  
  572. adasem(align_clause);
  573. sem_list(comp_clause_list);
  574. find_old(name_node);
  575. type_name = N_UNQ(name_node);
  576.  
  577. if (!is_record(type_name)) {
  578.    errmsg("Identifier is not a record type", "13.4", name_node);
  579.    return ;
  580. }
  581.  
  582. repr_err = FALSE;
  583. if (align_clause == OPT_NODE) {
  584.   modulus_value = 0;
  585. }
  586. else {
  587.   check_type(symbol_integer, align_clause);
  588.   if (is_static_expr(align_clause)) {
  589.      modulus_value = INTV((Const)N_VAL(align_clause));
  590.   }
  591.   else {
  592.      errmsg("Alignment clause must contain a static expression", "13.4", align_clause);
  593.      repr_err = TRUE;
  594.    }
  595. }
  596. location_lists = tup_new(0);
  597. field_names = tup_new(0);
  598. FORDECLARED(field,comp,(Declaredmap)declared_components(base_type(type_name)),fd)
  599.    field_names = tup_with(field_names,field);
  600. ENDFORDECLARED(fd)
  601.  
  602. duplic_list = tup_new(0);
  603.  
  604. FORTUP(comp_clause=(Node), N_LIST(comp_clause_list), ft1)
  605.   field = N_VAL(N_AST1(comp_clause)); 
  606.   rel_addr = N_AST2(comp_clause);
  607.   bit_range = N_AST3(comp_clause); /* range node */
  608.    
  609.    if (!tup_memstr(field, field_names)) {
  610.     /* must verify what field in following errmsg calls (gs sep 20) */
  611.       errmsg_str("Component % does not appear in record type", field, "none",(Node)0);
  612.       repr_err = TRUE;
  613.    }
  614.    else if (tup_memstr(field,duplic_list)) {
  615.       errmsg_str("Component % already occurs in clause", field,"none",(Node)0);
  616.       repr_err = TRUE;
  617.    }
  618.    else {
  619.       duplic_list = tup_with(duplic_list,field);
  620.    }
  621.  
  622.    check_type (symbol_integer, rel_addr);
  623.    if (is_static_expr (rel_addr)) {
  624.       rel_addr_val = INTV((Const) N_VAL(rel_addr));
  625.    }
  626.    else {
  627.       errmsg_str("Expression for component % must be static", field,"13.4", rel_addr);
  628.       repr_err = TRUE;
  629.    }
  630.    
  631.    if (N_KIND(bit_range) == as_range) {
  632.       first_bit = N_AST1(bit_range);
  633.       last_bit = N_AST2(bit_range);
  634.       check_type (symbol_integer, first_bit);
  635.       check_type (symbol_integer, last_bit);
  636.       if (is_static_expr(first_bit) && is_static_expr(last_bit)) {
  637.      loc_list = tup_new(4);
  638.      loc_list[1] = field;
  639.      loc_list[2] = (char *) rel_addr_val;
  640.      loc_list[3] = (char *) INTV((Const) N_VAL(first_bit));
  641.      loc_list[4] = (char *) INTV((Const) N_VAL(last_bit));
  642.      location_lists = tup_with(location_lists, (char *)loc_list);
  643.        }
  644.        else  {
  645.      errmsg_str("Range for component % must be static",field, "13.4",(Node)0);
  646.      repr_err = TRUE;
  647.        }
  648.    }
  649. ENDFORTUP(ft1)
  650.  
  651.   if (repr_err) {
  652.      return;
  653.   }
  654.   else {
  655.      apply_record_clause(type_name, modulus_value, location_lists);
  656.   }
  657. }
  658. static void apply_record_clause(Symbol type_name, 
  659.                                 int modulus_value, Tuple location_lists)
  660. /*;apply_record_clause*/
  661.  
  662. {
  663.     Symbol    b_type;
  664.     char    *field;
  665.     Tuple    current_rep,attribute_list,tup,tup2,tup4;
  666.     int        offset,position,first_bit,start_bit,end_bit;
  667.     int        start_unit,field_size,record_size;
  668.     Fortup    ft1;
  669.     Declaredmap    decls;
  670.  
  671.     b_type = base_type(type_name);
  672.     current_rep = RCINFO(b_type);
  673.     record_size = 0;
  674.     attribute_list = tup_new(0);
  675.     decls = (Declaredmap) declared_components(b_type);
  676.  
  677.    FORTUP(tup=(Tuple),location_lists,ft1);
  678.       field = tup[1];
  679.       start_unit = (int) tup[2];
  680.       start_bit = (int) tup[3];
  681.       end_bit = (int) tup[4];
  682.       offset = storage_unit * start_unit + start_bit;
  683.       position = offset / storage_unit;
  684.       first_bit = offset % storage_unit;
  685.       field_size = end_bit - start_bit + 1;
  686.       record_size = max_val(record_size, (offset + field_size));
  687.       tup4 = tup_new(4);
  688.       tup4[1] = (char *) dcl_get(decls, field);
  689.       tup4[2] = (char *) position;
  690.       tup4[3] = (char *) first_bit;
  691.       tup4[4] = (char *) (first_bit + field_size -1);;
  692.       attribute_list = tup_with(attribute_list, (char *) tup4);
  693.    ENDFORTUP(ft1);
  694.    tup2 = tup_new(2);
  695.    tup2[1] = (char *) modulus_value;
  696.    tup2[2] = (char *) attribute_list;
  697.    current_rep[alignment_position] = (char *) rc_set;
  698.    current_rep[alignment_position+1] = (char *) tup2;
  699.    current_rep[size_position] = (char *) rc_set;
  700.    current_rep[size_position+1] = (char *) record_size;
  701.    RCINFO(b_type) = current_rep;
  702. }
  703.  
  704. static Tuple not_chosen_get(Symbol sym)                        /*;not_chosen_get*/
  705. {
  706.     int     i,n;
  707.  
  708. n = tup_size(NOT_CHOSEN);
  709. for (i=1;i<=n; i+=2) {
  710.     if ((Symbol) NOT_CHOSEN[i]== sym) {
  711.     return (Tuple) NOT_CHOSEN[i+1];
  712.     }
  713. }
  714. return tup_new(0);
  715. }
  716. void not_chosen_put(Symbol sym1, Symbol sym2)        /*;not_chosen_put*/
  717. {
  718.     Tuple    tup;
  719.     int     i,n;
  720.  
  721. if (already_forced(sym1)) {
  722.    if (sym2 != (Symbol)0) choose_representation(sym2);
  723.    return;
  724. }
  725.  
  726. n = tup_size(NOT_CHOSEN);
  727. for (i=1;i<=n; i+=2) {
  728.     if ((Symbol) NOT_CHOSEN[i]==sym1) {
  729.        tup = (Tuple) NOT_CHOSEN[i+1];
  730.        if (sym2 != (Symbol)0)  { 
  731.           NOT_CHOSEN[i+1] = (char *) tup_with(tup, (char *) sym2);
  732.        }
  733.        return;
  734.     }
  735. }
  736. NOT_CHOSEN = tup_exp(NOT_CHOSEN, (unsigned) n+2);
  737. NOT_CHOSEN[n+1] = (char *) sym1;
  738. if (sym2 == (Symbol)0)
  739.     NOT_CHOSEN[n+2] = (char *) tup_new(0);
  740. else
  741.     NOT_CHOSEN[n+2] = (char *) tup_new1((char *)sym2);
  742. return;
  743. }
  744. static void not_chosen_delete(Symbol sym)                /*;not_chosen_delete*/
  745. {
  746.     int     i,n;
  747.  
  748. n = tup_size(NOT_CHOSEN);
  749. for (i=1;i<=n; i+=2) {
  750.     if ((Symbol) NOT_CHOSEN[i]== sym) {
  751.        NOT_CHOSEN[i] = NOT_CHOSEN[n-1];
  752.        NOT_CHOSEN[i+1] = NOT_CHOSEN[n];
  753.        NOT_CHOSEN[0] = (char *) n-2;
  754.        return;
  755.     }
  756. }
  757. }
  758. static default_size_value(Symbol type_name)            /*; default_size_value */
  759. /*
  760.  * Robert might want to add to this routine.
  761.  *
  762.  * If there were any errors in the compilation just return a default of 32
  763.  * rather than any more detailed calculation since the type might be
  764.  * an incorrect syntactic form (type 'any' or the like) or semantically
  765.  * incorrect. (i.e. using a floating point as the index type of an array)
  766.  */
  767. {
  768. int        size_v,num_of_comps;
  769. Fortup    ft1; 
  770. Tuple    bounds;
  771. Node    lo,hi;
  772. Symbol    i,component;
  773. Symbol    b_type, r_type, v_type, priv_decl;
  774. int        swap_private;
  775. Tuple    components;
  776. Symbol    field_name;
  777.  
  778. if (errors) {
  779.    return 32;
  780. }
  781. if (is_numeric_type(type_name)) {
  782.     size_v = 32;
  783. }
  784. else if (NATURE(root_type(type_name)) == na_enum) {
  785.   /*
  786.    * Some more elaborate code would be here to determine the # of bits
  787.    * depending on the # of enumeration values.
  788.    */
  789.    size_v = 8;
  790. }
  791. else if (is_array(type_name)) {
  792.    num_of_comps = 1;
  793.    FORTUP(i=(Symbol),index_types(type_name),ft1);
  794.       bounds = SIGNATURE(i);
  795.     /*
  796.      * The bounds are undefined in the case where one of the indices was
  797.      * some incorrect syntactic form (type 'any' or the like).
  798.      */
  799.  
  800.       if (bounds == (Tuple)0) {
  801.           return -1;
  802.       }
  803.  
  804.       lo = (Node) numeric_constraint_low(bounds);
  805.       hi = (Node) numeric_constraint_high(bounds);
  806.     /*
  807.      * The size of the array can be calculated now only if they are static
  808.      * and are integers. Static non-integer values can come about due to
  809.      * error conditions such as using a floating point type as the index.
  810.      * Non-static size is indicated with -1.
  811.      */
  812.  
  813.       if (!(is_static_expr(lo) && is_static_expr(hi))) {
  814.          return -1;
  815.       }
  816.       num_of_comps =  num_of_comps * 
  817.                       (INTV((Const)N_VAL(hi)) - INTV((Const)N_VAL(lo)) + 1);
  818.    ENDFORTUP(ft1);
  819.    component = component_type(type_name);
  820.    size_v = num_of_comps * default_size_value(component);
  821. }
  822. else if (is_record(type_name)) {
  823.    size_v = 0;
  824.    b_type = base_type(type_name);
  825.    swap_private = FALSE;
  826.    r_type = root_type(type_name);
  827. /*
  828.  * Check to see if either the base_type or the root_type is private and
  829.  * if it is swap the private decls with the visible part so that the record
  830.  * components can be made fully visible. We will swap them back at the end.
  831.  */
  832.    if (TYPE_OF(b_type) == symbol_private || 
  833.        TYPE_OF(b_type) == symbol_limited_private) {
  834.         swap_private = TRUE;
  835.    }
  836.    else if (TYPE_OF(r_type) == symbol_private || 
  837.                 TYPE_OF(r_type) == symbol_limited_private) {
  838.           b_type = r_type;
  839.           swap_private = TRUE;
  840.    }
  841.  
  842.    if (swap_private) {
  843.       v_type = private_decls_get((Private_declarations)
  844.                       private_decls(SCOPE_OF(b_type)), b_type);
  845.  
  846.       /*  Check for error condition and if so return standard size. */
  847.       if (v_type == (Symbol)0) {
  848.           return 32;
  849.       }
  850.       priv_decl = b_type ;
  851.       b_type = v_type ;
  852.    }
  853.  
  854.    components = build_comp_names((Node) invariant_part(b_type));
  855.    /* add in the disciminants to the invariant fields , but not the special
  856.     * constrained symbol
  857.     */
  858.    FORTUP(field_name=(Symbol),(Tuple) discriminant_list(b_type), ft1);
  859.       if (field_name != symbol_constrained) {
  860.         components = tup_with(components, (char *) field_name);
  861.       }
  862.    ENDFORTUP(ft1);
  863.  
  864. #ifdef TBSL
  865.    variant = variant_part(b_type);
  866.    /* Currently does not work with nested variants */
  867.    if (tup_size(variant) != 0) {
  868.       [-, variants] := variant;
  869.       for [-, decls] in variants loop
  870.          if decls /= ["null"] then
  871.             components +:= decls(1);
  872.          end if;
  873.       end loop;
  874.    }
  875. #endif 
  876.  
  877.    FORTUP(field_name=(Symbol),components, ft1);
  878.       size_v = size_v + component_size(TYPE_OF(field_name));
  879.    ENDFORTUP(ft1);
  880.       
  881.    if (swap_private)  {
  882.       b_type = priv_decl ;
  883.    }
  884. }
  885. else {
  886.    size_v = 32;
  887. }
  888. return size_v;
  889. }
  890.  
  891. static int component_size(Symbol type_name)            /*; component_size*/
  892.  
  893. /*
  894.  * Return the size of a component of a record or an array by first checking its
  895.  * representation. At this point since the type of the component should have 
  896.  * been forced already we just need to extract the size given in the 
  897.  * representation. This was derived by either an explicit rep clause specifying
  898.  * the size or computed based on some default formula. In the case where the 
  899.  * type was not forced yet a default size is calculated for it.
  900.  */
  901.  
  902. {
  903. if (REPR(type_name) != (Tuple)0) {
  904.    return (int) REPR(type_name)[size_position];
  905. }
  906. else {
  907.    /* Type was not forced yet. (Probably some error condition) */
  908.    return default_size_value(type_name);
  909. }
  910. }
  911.  
  912. static Tuple default_record_value(Symbol type_name)        /*;default_record_value */
  913. {
  914.     Symbol     b_type,r_type,v_type, field_name, priv_decl;
  915.     int        swap_private;
  916.     Tuple    attribute_list, tup2, tup4, field_names;
  917.     int        position, first_bit, field_size, current_offset;
  918.     int        record_size;
  919.     Fortup    ft1;
  920.  
  921.  
  922.        b_type = base_type(type_name);
  923.        swap_private = FALSE;
  924.        r_type = root_type(type_name);
  925.  
  926. /* 
  927.  * Check to see if either the base_type or the root_type is private and
  928.  * if it is swap the private decls with the visible part so that the record
  929.  * components can be made fully visible. We will swap them back at the end.
  930.  */
  931.    if (TYPE_OF(b_type) == symbol_private ||
  932.        TYPE_OF(b_type) == symbol_limited_private) {
  933.        swap_private = TRUE;
  934.    }
  935.    else if (TYPE_OF(r_type) == symbol_private ||
  936.             TYPE_OF(r_type) == symbol_limited_private) {
  937.           b_type = r_type;
  938.           swap_private = TRUE;
  939.    }
  940.   if (swap_private) {
  941.       v_type = private_decls_get((Private_declarations)
  942.                       private_decls(SCOPE_OF(b_type)), b_type);
  943.  
  944.       priv_decl = b_type ;
  945.       b_type = v_type ;
  946.    }
  947.  
  948. current_offset = 0;
  949. attribute_list = tup_new(0);
  950. #ifdef TBSL
  951. variant := ST(b_type).signature.variant_part;
  952.  
  953. -- Currently does not work with nested variants
  954. if variant /= [] then
  955.    [-, variants] := variant;
  956.  
  957.    for [-, decls] in variants loop
  958.       if decls /= ["null"] then
  959.          components +:= decls(1);
  960.       end if;
  961.    end loop;
  962. end if;
  963. #endif
  964.  
  965. field_names = build_comp_names((Node) invariant_part(b_type));
  966. FORTUP(field_name=(Symbol),field_names, ft1);
  967.    position = current_offset / storage_unit;
  968.    first_bit = current_offset % storage_unit;
  969.    field_size = component_size(TYPE_OF(field_name)) + padding;
  970.    current_offset = current_offset + field_size + padding;
  971.    tup4 = tup_new(4);
  972.    tup4[1] = (char *) field_name;
  973.    tup4[2] = (char *) position;
  974.    tup4[3] = (char *) first_bit;
  975.    tup4[4] = (char *) (first_bit + field_size -1);
  976.    attribute_list = tup_with (attribute_list, (char *) tup4);
  977. ENDFORTUP(ft1);
  978.        
  979. /* Ignore record size for now */
  980. record_size = current_offset + padding;
  981.  
  982. if (swap_private) {
  983.    b_type = priv_decl ;
  984. }
  985. tup2 = tup_new(2); 
  986. tup2[1] = (char *) 0;
  987. tup2[2] = (char *) attribute_list;
  988. return tup2;
  989. } 
  990.  
  991. Node size_attribute(Node expn)                         /*;size_attribute*/
  992. {
  993. Symbol    typ1, v_type,b_type;
  994. Tuple    current_rep;
  995. Node    typ_node;
  996. int        size_value;
  997.  
  998. typ_node = N_AST2(expn);
  999. if (N_KIND(typ_node) != as_simple_name) {
  1000.     typ1 = N_TYPE(typ_node);
  1001. }
  1002. else {
  1003.     typ1 = N_UNQ(typ_node);
  1004. }     
  1005. if (!is_type(typ1)) {
  1006.    typ1 = TYPE_OF(typ1);
  1007. }
  1008. if (!is_static_subtype(typ1)) {
  1009.    return expn;
  1010. }
  1011. if (is_generic_type(typ1)) {
  1012.    return expn;
  1013. }
  1014. if (TYPE_OF(typ1) == symbol_private ||   
  1015.     TYPE_OF(typ1) == symbol_limited_private) {
  1016.     v_type = private_decls_get((Private_declarations)
  1017.                                   private_decls(SCOPE_OF(typ1)), typ1);
  1018.     /*
  1019.      * Check to seem if vis_decl is defined before accessing it. It might be
  1020.      * undefined in the case of compilation errors.
  1021.      */
  1022.      if (v_type != (Symbol)0) {
  1023.          typ1 = TYPE_OF(v_type);     /* TYPE_OF field in the symbol table */
  1024.      }
  1025. }
  1026. if (is_scalar_type(typ1)) {
  1027.    b_type = base_type(typ1);
  1028.    force_representation(b_type);
  1029.    current_rep = RCINFO(b_type);
  1030.    if ((int) current_rep[size_position] == rc_unset) {
  1031.       size_value = default_size_value(b_type);
  1032.    }
  1033.    else {
  1034.       size_value = (int) current_rep[size_position+1];
  1035.    }
  1036.    return new_ivalue_node(uint_const(int_fri(size_value)), symbol_integer);
  1037. }
  1038. else {
  1039.    return expn;
  1040. }
  1041. }
  1042. #ifdef ERRORS
  1043. #endif
  1044.